<%@ language="vbscript"%>
<%
Option Explicit

'Version 1.1
'	Added ability to sort field order
'	Added ability to test results.  If you set the SenderName field to 'test' when
'	  you submit the form, the results will appear on-screen instead of sending a mail
'
'Version 1.0
'	Initial release

Dim g_strMailServer      'The SMTP server used for sending the e-mail
Dim g_arrAcceptedDomains 'An array of domains that this script will accept

'A hard timeout for this script, just in case
Server.ScriptTimeout = 30

'~~~~~ Change these values to suit your environment ~~~~~
g_strMailServer      = "smtp.mydomain.org"
g_arrAcceptedDomains = Array("www.mydomain.org", _
							"mydomain.co.uk")
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Function ProcessForm
	'#region <Dimension Variables>
	Dim strRequiredFields 'Comma-separated string of required standard fields
	Dim arrRequiredFields 'Array of required fields including user-specified fields
	Dim arrReferer        'Array of HTTP_REFERRER split by '/'
	Dim blnVerified       'Boolean indicating whether the referring domain has been accepted
	Dim strDomain         'The current domain being checked from [g_arrAcceptedDomains]
	Dim strField          'The current form field being checked
	Dim strErrResponse    'Error detail string for use when required fields are missing
	Dim blnRequired       'Boolean indicating whether all required fields have been completed
	Dim strSenderName     'The name of the person submitting the form
	Dim strSenderEmail    'The e-mail address of the person submitting the form
	Dim strRecipient      'The e-mail address that will recieve the form data
	Dim strSubject        'The subject line for the form data e-mail
	Dim strSuccessPage    'The page that the user will be redirected to on successful processing of the form
	Dim strFormOutput     'The output data from the form
	Dim strBody           'The message body for the e-mail message
	Dim strErr            'The error code from the e-mail function
	'#endregion
	
	'Create array of required fields
	strRequiredFields = "sendername,recipient,subject,senderemail,successpage" 
	If Len(Request.Form.Item("required")) Then strRequiredFields = strRequiredFields & "," & Request.Form.Item("required")
	arrRequiredFields = Split(strRequiredFields, ",")
	
	'#region <Verfiy the referring domain>
	arrReferer = Split(Request.ServerVariables("HTTP_REFERER"), "/")
	blnVerified = False
	For Each strDomain in g_arrAcceptedDomains
		If arrReferer(2) = strDomain Then blnVerified = True
	Next
	If Not blnVerified Then
		ProcessForm = "<h3 class='fail'>Referring URL cannot be verified!</h3>"
		ProcessForm = ProcessForm & "<p>Referrer: " & arrReferer(2) & "</p>"
		ProcessForm = ProcessForm & "<h4 class='fail'>Message rejected</h4>"
		Exit Function
	End If
	'#endregion
	
	'#region <Check required fields exist>
	For Each strField In arrRequiredFields
		If Len(Request.Form.Item(strField)) = 0 Then
			strErrResponse = strErrResponse & "<li>You must complete the " & strField & " field.</li>" & VbCrLf
			blnRequired = True
		End If
	Next
	
	If blnRequired Then
		ProcessForm = "<h3>Error processing form</h3>" & VbCrLf
		ProcessForm = ProcessForm & "<ul>" & strErrResponse & "</ul>" & VbCrLf
		ProcessForm = ProcessForm & "<p>Please click the back button to check the information you entered, or <a href='" _
					& Request.ServerVariables("HTTP_REFERER") & "'>click here</a> to start with an empty form.</p>" & VbCrLf
		Exit Function
	End If
	'#endregion
	
	'#region <Get form data>
	On Error Resume Next
	For Each strField In SortFields(Request.Form) 'Request.Form
		Select Case Lcase(strField)
			Case "sendername"
				strSenderName  = Request.Form.Item(strField)
				strFormOutput = strFormOutput & "<li>" & strField & " = " & Request.Form.Item(strField) & "</li>" & VbCrLf
			Case "senderemail"
				strSenderEmail = Request.Form.Item(strField)
				strFormOutput = strFormOutput & "<li>" & strField & " = " & Request.Form.Item(strField) & "</li>" & VbCrLf
			Case "recipient"
				strRecipient   = Request.Form.Item(strField)
			Case "subject"
				strSubject     = Request.Form.Item(strField)
			Case "successpage"
				strSuccessPage = Request.Form.Item(strField)
			Case "required", "sortorder"
				'Do nothing - this is just the list of required fields and their sort order
			Case "submit","button"
				'Do nothing - this is the submit button and this data is not required
			Case Else
				'Unknown form field - just add to the output
				If Len(strField) > 0 Then
					strFormOutput = strFormOutput & "<li>" & strField & " = " & Request.Form.Item(strField) & "</li>" & VbCrLf
					If Err.Number Then
						strFormOutput = strFormOutput & "<li>" & strField & "(ERROR)</li>" & vbcrlf
					End If
				End If
		End Select
	Next
	On Error GoTo 0
	'#endregion
	
	'#region <Send message>
	'Check e-mail address supplied is valid
	If Not IsEmail(strSenderEmail) Then
		ProcessForm = "<h3>Error processing form</h3>" & VbCrLf
		ProcessForm = ProcessForm & "<ul>" & strFormOutput & "</ul>" & VbCrLf
		ProcessForm = ProcessForm & "<p>'" & strSenderEmail & "' is not valid.</p>" & VbCrLf 
		ProcessForm = ProcessForm & "<p class='fail'>You must supply a valid e-mail address.</p>" & VbCrLf
		Exit Function
	End If
	
	strBody = "<p>Here are the details submitted by " & strSenderName & " from the " & Request.ServerVariables("HTTP_REFERER") & " form.</p>" & VbCrLf
	strBody = strBody & "<ul>" & strFormOutput & "</ul>" & VbCrLf
	strBody = strBody & "<hr />" & VbCrLf

	'This line should allow the e-mail through spam filters.  Just add a word from the exceptions list.
	'strBody = strBody & "<p class='hidden'>P.S. This message has unblockability :)</p>" & VbCrLf
	
	If Request.Form.Item("sendername") = "test" Then
		ProcessForm = strBody
	Else
		strErr = SendMail(g_strMailServer, strRecipient, strSenderEmail, strSubject, AddStyles & strBody)
		If Left(strErr, 1) <> "0" Then
			ProcessForm = ProcessForm & "Error sending message - " & strErr
		Else
			ProcessForm = ProcessForm & "Message     = " & strBody
			ProcessForm = ProcessForm & "Recipient   = " & strRecipient & "<br />" & VbCrLf
			ProcessForm = ProcessForm & "Sender      = " & strSenderEmail & "<br />" & VbCrLf
			ProcessForm = ProcessForm & "Subject     = " & strSubject & "<br />" & VbCrLf
			ProcessForm = ProcessForm & "SmtpServer  = " & g_strMailServer & "<br />" & VbCrLf
			ProcessForm = ProcessForm & "SuccessPage = " & strSuccessPage
			'Disable the next line when troubleshooting
			Response.Redirect strSuccessPage
		End If
	End If
	'#endregion
End Function

Function SendMail(strMailServer, strTo, strFrom, strSubject, strMessage)
	'#region <Dimension Variables>
	Dim objMessage 'CDO Message object
	Dim objConfig  'CDO Configuration object
	Dim objFields  'Fields object from [objConfig]
	'#endregion
	
	'Set the Visual Basic constants as they do not exist within VBScript.
	Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
	Const cdoSMTPServer      = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
	Const cdoSendUsingPort   = 2
	
	'Create the CDO connections.
	Set objMessage = CreateObject("CDO.Message")
	Set objConfig  = CreateObject("CDO.Configuration")
	Set objFields  = objConfig.Fields
	
	'SMTP server configuration.
	With objFields
		.Item(cdoSendUsingMethod) = cdoSendUsingPort
		.Item(cdoSMTPServer)      = strMailServer
		.Update
	End With
	
	'Set the message properties.
	On Error Resume Next
	With objMessage
		Set .Configuration = objConfig
		.To       = strTo
		.From     = strFrom
		.Subject  = strSubject
		.HTMLBody = strMessage
	End With         
	
	'Send the message.
	Err.Clear
	objMessage.Send
	SendMail = Err.Number & ", " & Err.Description
	On Error GoTo 0
	
End Function

Function IsEmail(strEmail)
	'#region <Dimension Variables>
	Dim arrSections 'Array of mailbox and mail domain
	Dim strPart     'The current part of [arrSections] being checked
	Dim intPos      'Simple counter to loop through each character in [strPart]
	Dim strChar     'The current character in [strPart]
	Dim intTld      'The length of the top level domain
	'#endregion
	
	'Bad syntax assumed until proven otherwise
	IsEmail = False
	
	'Split e-mail into user and domain sections
	arrSections = Split(strEmail, "@")
	
	'Quit unless there is only one '@'
	If UBound(arrSections) <> 1 Then Exit Function
	
	For Each strPart in arrSections
		'Check length
		If Len(strPart) <= 0 Then Exit Function
		
		'Check each character is valid
		For intPos = 1 to Len(strPart)
			strChar = Cstr(Lcase(Mid(strPart, intPos, 1)))
			If InStr("abcdefghijklmnopqrstuvwxyz0123456789_-.", strChar) = 0 Then Exit Function
		Next
		
		'Check part doesn't begin or end with a '.'
		If Left(strPart, 1) = "." or Right(strPart, 1) = "." Then Exit Function
	Next
	
	'Ensure domain part has a '.'
	If InStr(arrSections(1), ".") <= 0 Then Exit Function
	
	'Ensure TLD is in the correct size range
	intTld = Len(arrSections(1)) - InStrRev(arrSections(1), ".")
	If intTld < 2 Or intTld > 7 Then Exit Function
	
	'Ensure that '..' doesn't appear in address
	If InStr(strEmail, "..") > 0 Then Exit Function
	
	'Made it!  It must be a good syntax then...
	IsEmail = True
	
End Function

Function AddStyles
	'Generate CSS style sheet for e-mail output
	AddStyles = "  <style type=""text/css"" media=""screen""> <!--" & VbCrLf
	AddStyles = AddStyles & "	body,td,p,li  {font-size:12px; font-family:Tahoma,Arial,Helvetica;}" & VbCrLf
	AddStyles = AddStyles & "	caption {font-size: 11px; font-weight:bold;}" & VbCrLf
	AddStyles = AddStyles & "	tr.odd  {background-color:#eee;}" & VbCrLf
	AddStyles = AddStyles & "	hr {width:770px; height:1px; text-align:left;}" & VbCrLf
	AddStyles = AddStyles & "	tr {background-color:#ddd;}" & VbCrLf
	AddStyles = AddStyles & "	td {padding-left:5px; padding-right:2px;}" & VbCrLf
	AddStyles = AddStyles & "	th {background-color:#666; color:white; font-size:11px; text-align:left; padding-left:5px; padding-right:2px;}" & VbCrLf
	AddStyles = AddStyles & "	.highlight {color:blue; font-weight:bold;}" & VbCrLf
	AddStyles = AddStyles & "	.subtitle  {font-size:11px; font-weight:bold; text-align:center;}" & VbCrLf
	AddStyles = AddStyles & "	.heading   {font-size:14px; font-weight:bold;}" & VbCrLf
	AddStyles = AddStyles & "	.fail   {color:red; font-size:11px; font-weight:bold;}" & VbCrLf
	AddStyles = AddStyles & "	.note   {font-size: 11px; font-weight:normal; color:blue;}" & VbCrLf
	AddStyles = AddStyles & "	.fixed  {font-family:'Lucida Console','Courier New',Courier;}" & VbCrLf
	AddStyles = AddStyles & "	.title  {font-size:15px; font-weight:bold; text-align:center;}" & VbCrLf
	AddStyles = AddStyles & "	.mouse  {font-size:9px;}" & VbCrLf
	AddStyles = AddStyles & "	.hidden {font-size:9px; color: #ffffff;}" & VbCrLf
	AddStyles = AddStyles & "  --></style>" & VbCrLf
End Function

Function SortFields(arrFields)
	Dim arrSortedFields
	Dim arrSortOrder
	Dim dctSortOrder
	Dim strItem
	
	If Len(Request.Form.Item("sortorder")) = 0 Then
		Set SortFields = arrFields
	ElseIf Request.Form.Item("sortorder") = "asc" Then
		SortFields = SortArray(arrFields, True)
	ElseIf Request.Form.Item("sortorder") = "desc" Then
		SortFields = SortArray(arrFields, False)
	Else
		Set dctSortOrder = CreateObject("Scripting.Dictionary")
		For Each strItem In Split(Request.Form.Item("sortorder"), ",")
			If Not dctSortOrder.Exists(strItem) Then dctSortOrder.Add strItem, strItem
		Next
		For Each strItem In arrFields
			If Not dctSortOrder.Exists(strItem) Then dctSortOrder.Add strItem, strItem
		Next
		SortFields = dctSortOrder.Items
	End If
End Function

Function SortArray(arrData, blnAscending)
	Const adVarChar     = 200
	Const MaxCharacters = 1024
	Dim objConn
	Dim objRS
	Dim strData
	Dim intCount
	ReDim arrTemp(0)
	
	Set objRS = Server.CreateObject("ADOR.Recordset")
	objRS.Fields.Append "Data", adVarChar, MaxCharacters
	objRS.Open
	
	For Each strData In arrData
		objRS.AddNew
		objRS("Data") = strData
		objRS.Update
	Next
	
	If blnAscending Then
		objRS.Sort = "Data ASC"
	Else
		objRS.Sort = "Data DESC"
	End If
	
	objRS.MoveFirst
	intCount = 0
	Do Until objRS.EOF
		arrTemp(intCount) = objRS("Data")
		intCount = intCount + 1
		ReDim Preserve arrTemp(intCount)
		objRS.MoveNext
	Loop
	
	SortArray = arrTemp
	
	objRS.Close
End Function

%>

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
	<head>
		<meta http-equiv="content-type" content="text/xhtml+xml;charset=iso-8859-1" />
		<title>ASP Form Mail - Error Page</title>
	</head>
	<body>
		<h2>ASP Form Mail</h2>
		<%=ProcessForm%>
	</body>
</html>
